(in-package :lilu-debugger)

;;;
;;; break hook variable
;;;
(defmacro %with-break-hook-sym ((break-hook-sym) &body body)
  `(symbol-macrolet ((,break-hook-sym (quote
                       #+sbcl       sb-ext:*invoke-debugger-hook*
                       #+ccl        ccl:*break-hook*
                       #+ecl        ext:*invoke-debugger-hook*
                       #+clasp      ext:*invoke-debugger-hook*
                       #+abcl       sys::*invoke-debugger-hook*
                       #+clisp      sys::*break-driver*
                       #+allegro    excl::*break-hook*
                       #+lispworks  dbg::*debugger-wrapper-list*
                       #+mezzano    mezzano.debug:*global-debugger*)))
     ,@body))

(defmacro %with-break-hook-var ((break-hook-var) &body body)
  `(symbol-macrolet ((,break-hook-var
                       #+sbcl       sb-ext:*invoke-debugger-hook*
                       #+ccl        ccl:*break-hook*
                       #+ecl        ext:*invoke-debugger-hook*
                       #+clasp      ext:*invoke-debugger-hook*
                       #+abcl       sys::*invoke-debugger-hook*
                       #+clisp      sys::*break-driver*
                       #+allegro    excl::*break-hook*
                       #+lispworks  dbg::*debugger-wrapper-list*
                       #+mezzano    mezzano.debug:*global-debugger*))
     ,@body))

;;;
;;; set/set global values
;;;

(defmacro %value (var &key force-global-p)
  `(if ,force-global-p
       (bt:join-thread
        (bt:make-thread #'(lambda ()
                            ,var)))
       ,var))

(define-setf-expander %value (var &key force-global-p &environment env)
  (multiple-value-bind (dummies vals newval setter getter)
      (get-setf-expansion var env)
    (declare (ignorable setter newval))
    (let ((store (gensym)))
      (values dummies
              vals
              `(,store)
              `(if ,force-global-p
                   (bt:make-thread #'(lambda ()
                                       (setf ,var ,store)))
                   (setq ,var ,store))
              `,getter))))

;;;
;;; debugger hook
;;;

(defvar *old-debugger-hook* nil)

(defun debugger-hook! (condition me-or-my-encapsulation)
  (when *debugger*
    (let ((*debugger-hook*))
      (lilu-app:invoke-debugger-hook condition me-or-my-encapsulation
                                     :debugger *debugger*)))
  (when *old-debugger-hook*
    (funcall *old-debugger-hook*
             condition me-or-my-encapsulation )))

(defun enable-debugger (&key (force-global-p nil))
  (if (eql (%value *debugger-hook* :force-global-p force-global-p)
           #'debugger-hook!)
      (warn "debugger already enabled")
      (progn
        (setf *old-debugger-hook* (%value *debugger-hook* :force-global-p force-global-p))
        (setf (%value *debugger-hook* :force-global-p force-global-p) #'debugger-hook!))))

(defun disable-debugger (&key (force-global-p nil))
  (if (eql (%value *debugger-hook* :force-global-p force-global-p)
           #'debugger-hook!)
      (progn
        (setf (%value *debugger-hook* :force-global-p force-global-p) *old-debugger-hook*)
        (setf *old-debugger-hook* nil))
      (warn "debugger is not enabled")))

;;;
;;; break hook
;;;

(defvar *old-break-hook* nil)

(defun break-hook! (condition me-or-my-encapsulation)
  (when *debugger*
    (let ((*debugger-hook*))
      (lilu-app:invoke-debugger-hook condition me-or-my-encapsulation
                                     :debugger *debugger*)))
  (when *old-break-hook*
    (funcall *old-break-hook*
             condition me-or-my-encapsulation )))

(defun enable-break (&key (force-global-p nil))
  (%with-break-hook-var (break-hook)
    (if (eql (%value break-hook :force-global-p force-global-p) #'break-hook!)
        (warn "break already enabled")
        (progn
          (setf *old-break-hook* (%value break-hook :force-global-p force-global-p))
          (setf (%value break-hook :force-global-p force-global-p) #'break-hook!)))))

(defun disable-break (&key (force-global-p nil))
  (%with-break-hook-var (break-hook)
    (if (eql (%value break-hook :force-global-p force-global-p) #'break-hook!)
        (progn
          (setf (%value break-hook :force-global-p force-global-p) *old-break-hook*)
          (setf *old-break-hook* nil))
        (warn "break is not enabled"))))

;;;
;;;
;;;

(defstruct debugger-rt
  (ignore-p))

(defvar *debugger-rt* (make-debugger-rt))

;;;
;;; with-*
;;;

(defmacro with-break-on-signals ((condition) &body body)
  (%with-break-hook-sym (break-hook)
    `(if (eql ,condition :none)
         (progn
           ,@body)
         (let ((*break-on-signals* ,condition)
               (,break-hook nil))
           (enable-break)
           ,@body))))

(defmacro with-debugger ((&optional (debugger-name :default) (on-signal :none)) &body body)
  (let ((debugger-sym (gensym "DEBUGGER-")))
    `(let ((,debugger-sym
             (if (eql ,debugger-name :none)
                 nil
                 (find-debugger ,debugger-name))))
       (with-break-on-signals (,on-signal)
         (restart-case
             (if ,debugger-sym
                 (let ((*debugger* ,debugger-sym)
                       (*debugger-hook*)
                       (*debugger-rt* (make-debugger-rt)))
                   (enable-debugger)
                   ,@body)
                 (progn
                   ,@body))
           (abort-debugger ()
             :report (lambda (stream)
                       (format stream
                               "Abort (with-debugger ~S)"
                               ,debugger-name))))))))

(defmacro ignore-conditions (&body body)
  `(restart-case
       (unwind-protect
            (progn
              (setf (debugger-rt-ignore-p *debugger-rt*) t)
              ,@body)
         (setf (debugger-rt-ignore-p *debugger-rt*) nil)  )
     (ignore-debugger ()
       :report (lambda (stream)
                 (format stream
                         "Ignore (with-debuger)")))))

;;;
;;; standard debuggers
;;;

(defun debugger-check-ignore-restart (condition)
  (let ((ig (find-restart 'ignore-debugger condition)))
    (when ig
      (format *debug-io* "ignore on condition: ~A~%" condition)
      (invoke-restart ig))))

(defmacro with-standard-hook ((condition-var me-or-my-encapsulation-var) &body body)
  (declare (ignorable me-or-my-encapsulation-var))
  `(let ((*debugger-hook*))
     (when (debugger-rt-ignore-p *debugger-rt*)
       (debugger-check-ignore-restart ,condition-var))
     ,@body
     (anaphora:awhen (find-restart 'abort ,condition-var)
       (invoke-restart anaphora:it))))

(defmacro make-standard-hook ((name condition-var me-or-my-encapsulation-var) &body body)
  (let ((lambda-name (intern
                      (format nil "invoke-hook-~A" (if (symbolp name)
                                                       (symbol-name name)
                                                       name)))))
    `(labels ((,lambda-name (,condition-var ,me-or-my-encapsulation-var)
                (declare (ignorable ,me-or-my-encapsulation-var))
                (with-standard-hook (,condition-var ,me-or-my-encapsulation-var)
                  ,@body)))
       #',lambda-name)))

;;;
;;;
;;;

(defclass simple-debugger-application (lilu-app:simple-debugger-application-mixin
                                       lilu-app:application)
  ())

(defmethod lilu-app:application-installed-p ((app simple-debugger-application) &key force-p)
  (declare (ignore app force-p))
  t)

(defun register-simple-debugger (string-designator hook)
  (lilu-app:register-application
   (make-instance 'simple-debugger-application
                  :name (string string-designator)
                  :tags '(:debugger)
                  :debugger-hook hook)))

;;;
;;; predefined debuggers
;;;

(defun abort-debugger-hook (condition me-or-my-encapsulation)
  (declare (ignorable me-or-my-encapsulation))
  (with-standard-hook (condition me-or-my-encapsulation)
    (format *debug-io* "abort on condition: ~A~%" condition)
    (anaphora:awhen (find-restart 'abort-debugger condition)
      (invoke-restart anaphora:it))))

(defun quit-debugger-hook (condition me-or-my-encapsulation)
  (declare (ignorable me-or-my-encapsulation))
  (with-standard-hook (condition me-or-my-encapsulation)
    (format *debug-io* "quit on condition: ~A~%" condition)
    (cl-quit)))

(defvar *default-debugger* nil
  "The default debugger")

(defun default-debugger-hook (condition me-or-my-encapsulation)
  (with-standard-hook (condition me-or-my-encapsulation)
    (let ((debugger (lilu-app:find-debugger *default-debugger*)))
      (when debugger
        (lilu-app:invoke-debugger-hook condition me-or-my-encapsulation
                                       :debugger debugger)))))

(register-simple-debugger :abort #'abort-debugger-hook)
(register-simple-debugger :quit #'quit-debugger-hook)
(register-simple-debugger :default #'default-debugger-hook)

(setf *default-debugger* (lilu-app:find-debugger :abort))
(setf *debugger* (lilu-app:find-debugger :default))

;;;
;;; info
;;;

(defun debugger-system-info (&optional (stream t))
  (format stream "*debugger-hook* (local) : ~A~%" (%value *debugger-hook*))
  (format stream "*debugger-hook* (global): ~A~%" (%value *debugger-hook* :force-global-p t))
  (format stream "*old-debugger-hook* (local) : ~A~%" (%value *old-debugger-hook*))
  (%with-break-hook-sym (break-hook)
    (format stream "~s (local) : ~A~%" break-hook (%value (symbol-value break-hook)))
    (format stream "~s (global): ~A~%" break-hook (%value (symbol-value break-hook) :force-global-p t)))
  (format stream "*old-break-hook* (local) : ~A~%" (%value *old-break-hook*))
  (format stream "*default-debugger* (local) : ~A~%" (%value *default-debugger*))
  (format stream "*default-debugger* (global): ~A~%" (%value *default-debugger* :force-global-p t))
  (format stream "*debugger* (local) : ~A~%" (%value *debugger*))
  (format stream "*debugger* (global): ~A~%" (%value *debugger* :force-global-p t)))
